perm filename TRISC.F4[SAB,LCS] blob sn#353912 filedate 1978-05-10 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	C	PROGRAM TRISC
C00005 ENDMK
CāŠ—;
C	PROGRAM TRISC
	COMMON    X1(5),Y1(5),X2(5),Y2(5),G(1),H(1)
	1,X0(5),Y0(5),INK(5),IBUF(5000)
	COMMON /FAC/JFAC,KFAC
	DATA G/.4/
	DATA H/.4/         
	DATA X0/-.5,-.5,-.7,-.7,-.5/
	DATA Y0/.09,-.7,-.7,.09,.09/
	DATA X2/-1.,0.0,1.0,-1.,-1./
	DATA Y2/1.,0.0,-1.,-1.,1./
	DATA INK/3,2,2,2,2/
	TYPE 10
	ACCEPT 20,JFAC,KFAC
10	FORMAT(' TYPE X FACTOR AND Y FACTOR   '$)
20	FORMAT(2I)
	CALL PLOTS(IBUF,5000,1)
	CALL PLOT(1.,6.,-3)
 	D=3.
	RAD=.5
	ANG=15.
	DO 1 I=1,42
CC	DO 1 I=1,36
  	IF(I.NE.1)CALL ROTATE(X0,Y0,5,0.,0.,ANG)
	RAD1=RAD+R(.3)
	DO 50 I1=1,4    
	X1(I1)=X0(I1)+R(.2)
	Y1(I1)=Y0(I1)+R(.2)
 50	CONTINUE       
	X1(5)=X1(1)     
	Y1(5)=Y1(1)
  	IF(I.EQ.1)GO TO 100
  	CALL ROTATE(G,H,1,0.,0.,ANG)
  	CALL ROTATE(X2,Y2,5,0.,0.,ANG)
100	DO 2 M=1,10
	A=(10.-M)/9
	DO 3 N=1,5
	X=A*X1(N)+(1.-A)*X2(N)
	Y=A*Y1(N)+(1.-A)*Y2(N)
CC	TYPE 30,X,Y,A
30	FORMAT(3F)
	CALL PLOT(X,Y,INK(N))
 3	CONTINUE
  	CALL CIRCL2(RAD1,G,H)  
 2 	CONTINUE
	IF(I.EQ.42)GO TO 1
CC	IF(I.EQ.36)GO TO 1
CC41	L=MOD(I,6)
41	L=I-6*(I/6)
	IF(L.NE.0)CALL PLOT(D,0.,-3)
	IF(L.EQ.0)CALL PLOT(0.,2.05,-3)
	IF(L.EQ.0)D=-D
CC	TYPE 31,D
31	FORMAT(3F)
CC	TYPE 21,L
21	FORMAT(3I)
 1	CONTINUE
	CALL PLOT(0.,-30.,-3)
	CALL PLOT(0.,0.,999)
	STOP
	END
	FUNCTION R(Z)
	R=2.*Z*(RAN(1.)-.5)
	RETURN
	END
	SUBROUTINE FACTOR(X)
	COMMON Z(32)
	DO 1 K=1,22
 1	Z(K)=Z(K)*X
    	END